home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 007 / turbo_tk.arc / MENUTTT.PAS < prev    next >
Pascal/Delphi Source File  |  1988-02-01  |  19KB  |  491 lines
  1. {$S-,R-,V-,D-,T-}
  2. {\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\}
  3. {         TechnoJocks Turbo Toolkit v4.00            Released: Feb 1, 1988    }
  4. {                                                                             }
  5. {         Module: MenuTTT     --    menu displaying procedues                 }
  6. {                                                                             }
  7. {                       Copyright R. D. Ainsbury (c) 1986                     }
  8. {\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\}
  9.  
  10. Unit MenuTTT;
  11.  
  12. interface
  13.  
  14. Uses CRT, FastTTT, DOS, WinTTT, KeyTTT;
  15.  
  16.  
  17. const
  18.    Max_Choices = 30;
  19. type
  20.    Menu_record = record
  21.                   Heading1     : string;                { '' for no heading}
  22.                   Heading2     : string;
  23.                   Topic        : array[1..Max_Choices] of string;
  24.                   TotalPicks   : integer;
  25.                   PicksPerLine : byte;
  26.                   AddPrefix    : byte;                    {0 no, 1 No.'s, 2 Lets}
  27.                   TopLeftXY    : array[1..2] of byte;     {X,Y}
  28.                   Boxtype      : byte;                    {0,1,2,3, >3}
  29.                   Colors       : array[1..5] of byte;     {HF,HB,LF,LB,Box}
  30.                   Margins      : byte;
  31.                   AllowEsc     : boolean;                 {true if Esc will exit}
  32.                 end;
  33.  
  34. Procedure DisplayMenu(MenuDef: Menu_record;
  35.                       Window:Boolean;
  36.                       var Choice,Errorcode : integer);
  37. Implementation
  38.  
  39. Procedure DisplayMenu(MenuDef: Menu_record;
  40.                       Window:Boolean;
  41.                       var Choice,Errorcode : integer);
  42. Const
  43. Alphabet = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ';
  44. Numbers  = '123456789';
  45. var
  46. I,J,X2,Y2,heading_Lines : integer;
  47. TextWidth : byte;
  48.  
  49.  
  50.     Function Int_to_Str(Number:Integer):string;
  51.     var Temp : string;
  52.     begin
  53.        Str(Number,temp);
  54.        Int_to_Str := temp;
  55.     end;
  56.  
  57.     Function  Str_to_Int(Str:string):integer;
  58.     var temp,code : integer;
  59.     begin
  60.         If length(Str) = 0 then
  61.            Str_to_Int := 0
  62.         else
  63.         begin
  64.             val(Str,temp,code);
  65.             if code = 0 then
  66.                Str_to_Int := temp
  67.             else
  68.                Str_to_Int := 0;
  69.         end;
  70.     end;
  71.  
  72.    Procedure GetDimensions;
  73.    var Fullwidth,MaxWidth: integer;
  74.  
  75.      Procedure Validate_Prefix;         { 0   no prefix  }
  76.      begin                          { 1   numbers prefix}
  77.          with MenuDef do                { 2   letters prefix}
  78.          begin                          { 3   function key prefix}
  79.              If PicksPerLine < 1 then PicksPerLine := 1;
  80.              If (TotalPicks = 10) and (AddPrefix = 1) then
  81.                 AddPrefix := 3;
  82.              If (TotalPicks > 10) and (AddPrefix in [1,3]) then
  83.                 AddPrefix := 2;
  84.              If (Addprefix > 3) or (TotalPicks > 26) or (Addprefix < 0) then
  85.                 Addprefix := 0;
  86.              end; {do}
  87.      end; {Validate_Prefix}
  88.  
  89.    Procedure Add_Prefix;
  90.    var I : integer;
  91.    begin
  92.        With MenuDef do
  93.        begin
  94.            Case AddPrefix of
  95.            1 : for I := 1 to TotalPicks do
  96.                    Topic[I] := int_to_str(I) + ' ' + Topic[I];
  97.            2 : for I := 1 to TotalPicks do
  98.                    Topic[I] := Copy(Alphabet,I,1) + ' ' + Topic[I];
  99.            3 : If TotalPicks < 10 then
  100.                   for I := 1 to TotalPicks do
  101.                       Topic[I] := 'F'+Int_to_Str(I) + ' ' + Topic[I]
  102.                else
  103.                begin                           {add extra space for F10 }
  104.                    for I := 1 to 9 do
  105.                        Topic[I] := 'F'+Int_to_Str(I) + '  ' + Topic[I];
  106.                    Topic[10] := 'F10 '+ Topic[10];
  107.                end;
  108.            end; {case}
  109.        end;  {do}
  110.    end;  {proc Add_Prefix}
  111.  
  112.      Procedure Find_Longest_Topic;
  113.      var
  114.        I,J: integer;
  115.      begin
  116.          with MenuDef do
  117.          begin
  118.              Textwidth := 0;
  119.              For I := 1 to TotalPicks do
  120.                  If length(Topic[I]) > TextWidth then
  121.                     Textwidth := length(Topic[I]);         {find the longest text}
  122.          end;  {with}
  123.      end;   {Proc Find_Widest_Line}
  124.  
  125.    Procedure Adjust_Text_Width(Len:integer);
  126.    var I,J : integer;
  127.    begin
  128.        With MenuDef do
  129.        begin
  130.            For I := 1 to TotalPicks do
  131.                If length(Topic[I]) > Len then         {reduce it}
  132.                   Delete(Topic[I],succ(Len),length(Topic[I]) - Len)
  133.                else                                  {expand it}
  134.                   For J := length(Topic[I]) + 1 to Textwidth do
  135.                       Topic[I] :=  Topic[I] + ' ';
  136.        end; {do}
  137.    end;
  138.  
  139.    Procedure Determine_MaxWidth;
  140.    {findout the max internal menu space - MaxWidth}
  141.    begin
  142.        with MenuDef do
  143.        begin
  144.            If margins < 0 then Margins := 0;
  145.            If not (BoxType in [0..9]) then
  146.               BoxType := 0;
  147.            MaxWidth := 80 - 2*Margins - 1; {-1 for arrow symbol to left of pick}
  148.            Case BoxType of
  149.            1..4 : MaxWidth := MaxWidth - 2;     {box sides}
  150.            5    : MaxWidth := pred(MaxWidth);    {box shadow}
  151.            6..9 : MaxWidth := MaxWidth - 3;     {box sides and shadow}
  152.            end;
  153.        end; {with}
  154.    end;
  155.  
  156.    Procedure Validate_PicksPerLine;
  157.    begin
  158.        With MenuDef do
  159.        begin
  160.            If succ(TextWidth)*PicksPerLine <= MaxWidth then
  161.               exit;  {no adjustment necessary, everything fits}
  162.            If (TextWidth-2)*PicksPerLine <= Maxwidth  then
  163.                TextWidth := pred(MaxWidth div PicksperLine)
  164.            else
  165.            begin
  166.                While succ(TextWidth)*PicksPerLine > MaxWidth do
  167.                      PicksPerLine := pred(PicksPerLine);
  168.                If PicksPerLine = 0 then
  169.                begin
  170.                    TextWidth := pred(MaxWidth);
  171.                    PicksPerLine := 1;
  172.                end;
  173.            end;
  174.        end; {with}
  175.    end;  {Proc Validate_PicksPerLine}
  176.  
  177.    Procedure Determine_X_Dimensions;
  178.    {Checks to see if the menu will fit, if it won't it changes something!}
  179.    begin
  180.        With MenuDef do
  181.        begin
  182.            Fullwidth := succ(Textwidth)*PicksPerLine + 2*Margins;
  183.            Case BoxType of
  184.            1..4 : FullWidth := FullWidth + 2;     {box sides}
  185.            5    : FullWidth := succ(FullWidth);    {box shadow}
  186.            6..9 : FullWidth := FullWidth + 3;     {box sides and shadow}
  187.            end; {Case}
  188.            If TopleftXY[1] < 1 then
  189.               TopleftXY[1] := (80 - Fullwidth)  div 2;
  190.            If TopLeftXY[1] + Fullwidth < 80 then
  191.               X2 := TopleftXY[1] + Fullwidth
  192.            else
  193.            begin
  194.                X2 := 80;
  195.                TopLeftXY[1] := 80 - Fullwidth + 1;
  196.            end;
  197.        end; {with}
  198.    end; {Proc Determine_X_Dimensions}
  199.  
  200.    Procedure Determine_Y_Dimensions;
  201.    var
  202.       BoxLines,
  203.       TopicLines,
  204.       FullDepth  : integer;
  205.    begin
  206.        With MenuDef do
  207.        begin
  208.            TopicLines := TotalPicks div PicksPerLine;   {no of full rows of picks}
  209.            If TotalPicks mod PicksPerLine > 0 then     {+1 if partial row of picks}
  210.               TopicLines := succ(TopicLines);
  211.            Case BoxType of
  212.            0    : Boxlines := 0;
  213.            1..5 : BoxLines :=  2;     {box sides}
  214.            6..9: BoxLines :=  3;     {box sides and shadow}
  215.            end;
  216.            Heading_Lines := 0;
  217.            If length(Heading1) > 0 then
  218.               Heading_Lines := succ(Heading_Lines);
  219.            If length(Heading2) > 0 then
  220.               Heading_Lines := succ(Heading_Lines);
  221.            If Heading_Lines > 0 then                  {add a line for a gap}
  222.               Heading_Lines := succ(Heading_Lines);    {gap above topics}
  223.            If BoxType = 5 then
  224.               Heading_Lines := succ(Heading_Lines);
  225.            Fulldepth := BoxLines+TopicLines+Heading_Lines;
  226.            If Heading_Lines > 0 then
  227.              Fulldepth := succ(Fulldepth);  {+1 gap below topics if headings}
  228.  
  229.            If FullDepth > 25 then   {if it doesn't fit, drop off topics}
  230.            begin
  231.                If Heading_Lines > 0 then
  232.                   TotalPicks :=  (25 - BoxLines -Heading_Lines-1)*PicksPerLine
  233.                else
  234.                   TotalPicks :=  (25 - BoxLines - Heading_Lines)*PicksPerLine;
  235.                FullDepth := 25;
  236.            end;
  237.            If TopLeftXY[2] <= 0 then
  238.               TopLeftXY[2] := (25 - Fulldepth) div 2 +1;
  239.            If TopLeftXY[2] + Fulldepth - 1 <= 25 then
  240.            begin
  241.                If BoxType > 4 then   {shadow}
  242.                   Y2 := TopleftXY[2] + pred(Fulldepth) - 1
  243.                else
  244.                   Y2 := TopleftXY[2] + pred(Fulldepth);
  245.            end
  246.            else
  247.            begin
  248.                If BoxType > 4 then   {shadow}
  249.                   Y2 := 24
  250.                else
  251.                   Y2 := 25;
  252.                TopLeftXY[2] := 25 - Fulldepth + 1;
  253.            end;
  254.    end;   {do}
  255.    end; {Proc Determine_Y_Dimensions}
  256.  
  257.    begin                              {Get_Dimensions}
  258.        Validate_Prefix;
  259.        Add_Prefix;
  260.        Find_Longest_Topic;
  261.        Determine_MaxWidth;
  262.        Validate_PicksPerLine;
  263.        Adjust_Text_Width(TextWidth);
  264.        Determine_X_Dimensions;
  265.        Determine_Y_Dimensions;
  266.    end;   {proc GetDimensions}
  267.  
  268.    Procedure Write_Text(Item:integer;Highlight:boolean);
  269.    Var X,Y,A:integer;
  270.    begin
  271.        With MenuDEf do
  272.        begin
  273.            A := Item mod PicksPerLine;
  274.            Y := Item div PicksPerLine +TopleftXY[2] + ord(A <> 0);
  275.            Y := Y + Heading_lines - ord(Boxtype = 0);
  276.            If A = 0 then A := PicksPerLine;      {A is now the no of picks from left}
  277.            X := (A - 1)*(TextWidth + 1)+Margins+
  278.                 TopleftXY[1]+1 + ord(BoxType > 0);          {title width + 1 for a space}
  279.            If Highlight then
  280.            begin
  281.                WriteAt(X,Y,colors[1],colors[2],Topic[item]);
  282.                WriteAT(pred(X),Y,colors[5],colors[2],chr(16));  {write arrow head}
  283.            end
  284.            else
  285.            begin
  286.                WriteAT(X,Y,colors[3],colors[4],Topic[item]);
  287.                WriteAT(pred(X),Y,colors[3],colors[4],' ');       {remove arrow head}
  288.            end;
  289.        end;  {do}
  290.    end;  {Proc Write_Text}
  291.  
  292.    Procedure CreateMenu;
  293.    var I : integer;
  294.    begin
  295.    with MenuDef do
  296.    begin
  297.     If Window then
  298.      MkWin(TopleftXY[1],TopLeftXY[2],X2,Y2+1,colors[3],colors[4],0)
  299.     else
  300.      ClearText(TopleftXY[1],TopLeftXY[2],X2,Y2,colors[3],colors[4]);
  301.     If (BoxType in [5..9]) and (TopleftXY[1] > 1) then      {draw a shadow}
  302.     begin
  303.         For I := TopleftXY[2]+1 to Y2+1 do
  304.             WriteAt(pred(TopLeftXY[1]),I,colors[3],black,' ');
  305.         WriteAt(TopLeftXY[1],succ(Y2),colors[3],black,
  306.                 replicate(X2-succ(TopLeftXY[1]),' '));
  307.     end;
  308.     Case Boxtype of
  309.     1..4: Box(TopLeftXY[1],TopLeftXY[2],X2,Y2,colors[5],colors[4],Boxtype);
  310.     5   : begin
  311.               WriteAT(TopleftXY[1],TopleftXY[2],colors[5],colors[4],
  312.                       replicate(succ(X2 - TopleftXY[1]),chr(223)));
  313.               WriteAT(TopleftXY[1],TopleftXY[2]+Heading_Lines-1,colors[5],colors[4],
  314.                       replicate(succ(X2 - TopleftXY[1]),chr(196)));
  315.           end;
  316.     6..9:Box(TopLeftXY[1],TopLeftXY[2],X2,Y2,colors[5],colors[4],Boxtype-5);
  317.     end; {case}
  318.  
  319.     If length(Heading1) > 0 then
  320.        WriteBetween(TopleftXY[1],X2,
  321.                     TopLeftXY[2]+ord(BoxType > 0),
  322.                     colors[1],colors[4],Heading1);
  323.     If length(Heading2) > 0 then
  324.        WriteBetween(TopleftXY[1],X2,
  325.                     TopLeftXY[2]+ord(BoxType > 0)+ord(Heading_Lines <> 2),
  326.                     colors[1],colors[4],Heading2);
  327.     For I := 1 to TotalPicks do
  328.         Write_Text(I,false);
  329.     Write_Text(Choice,True);       {Highlight Default}
  330.    end; {do}
  331.    end; {Proc CreateMenu}
  332.  
  333.    Procedure Process_Keystrokes;
  334.    var
  335.      Selected: Boolean;
  336.      CHpk:char;
  337.      Oldchoice:integer;
  338.    begin
  339.    Selected := false;
  340.    With MenuDef do
  341.    begin
  342.        Repeat
  343.              Chpk := GetKey;
  344.              Case CHpk of
  345.              #208 : begin       {Cursor Down}
  346.                         Write_text(Choice,false);
  347.                         Choice := Choice + PicksPerLine;
  348.                         If Choice > TotalPicks then
  349.                            Choice := (Choice mod PicksPerLine) + 1;
  350.                         Write_Text(Choice,true);
  351.                     end;
  352.              #129 : If Choice + PicksPerLine  <= TotalPicks then  {Mouse Down}
  353.                     begin
  354.                         Write_text(Choice,false);
  355.                         Choice := Choice + PicksPerLine;
  356.                         Write_Text(Choice,true);
  357.                     end;
  358.              #200 : begin       {cursor up}
  359.                         Write_Text(Choice,false);
  360.                         Choice := Choice - PicksPerLine;
  361.                         If Choice < 1 then
  362.                         begin
  363.                            Choice := Choice + PicksPerline;
  364.                            Choice :=
  365.                              ((TotalPicks div PicksPerLine)*PicksPerLine)
  366.                              - PicksPerLine + 1 + Choice - 2;
  367.                            If Choice + PicksPerLine <= TotalPicks then
  368.                               Choice := Choice + PicksPerLine;   {phew!}
  369.                         end;
  370.                         Write_Text(Choice,true);
  371.                     end;
  372.              #128 : If Choice - PicksPerLine > 0 then   {Mouse up}
  373.                     begin
  374.                         Write_Text(Choice,false);
  375.                         Choice := Choice - PicksPerLine;
  376.                         Write_Text(Choice,true);
  377.                     end;
  378.              #203 : begin       {cursor left}
  379.                         Write_Text(Choice,False);
  380.                         Choice := pred(choice);
  381.                         If choice = 0 then Choice := TotalPicks;
  382.                         Write_Text(Choice,true);
  383.                     end;
  384.              #130 : If (pred(Choice) > 0)  {mouse left}
  385.                     and ( Choice mod PicksPerLine <> 1) then
  386.                     begin
  387.                         Write_Text(Choice,False);
  388.                         Choice := pred(choice);
  389.                         Write_Text(Choice,true);
  390.                     end;
  391.              ' ',
  392.              #205 : begin        {cursor right}
  393.                         Write_Text(Choice,false);
  394.                         Choice := succ(Choice);
  395.                         If choice > TotalPicks then Choice := 1;
  396.                         Write_Text(Choice,true);
  397.                     end;
  398.              #131 : If (succ(Choice) <= TotalPicks) {Mouse right}
  399.                     and ( Choice mod PicksPerLine <> 0) then
  400.                     begin
  401.                         Write_Text(Choice,false);
  402.                         Choice := succ(Choice);
  403.                         Write_Text(Choice,true);
  404.                     end;
  405.              #199 : begin         {home key}
  406.                         Write_Text(Choice,false);
  407.                         Choice := 1;
  408.                         Write_Text(Choice,true);
  409.                     end;
  410.              #207 : begin         {end key}
  411.                         Write_Text(Choice,false);
  412.                         Choice := TotalPicks;
  413.                         Write_Text(Choice,true);
  414.                     end;
  415.              #133,                 {Mouse enter}
  416.              #13  : begin          {enter key}
  417.                         Selected := true;
  418.                         Errorcode := 0;
  419.                     end;
  420.              #132,                    {Mouse Esc}
  421.              #27  : If AllowEsc then  {Esc}
  422.                     begin
  423.                         Selected := true;
  424.                         ErrorCode := 1;
  425.                     end
  426.                     else
  427.                     begin
  428.                         Write_Text(Choice,false);
  429.                         Choice := TotalPicks;
  430.                         Write_Text(Choice,true);
  431.                     end;
  432.              #187..#196 : If Addprefix = 3 then   {F1 to F10}
  433.                           begin
  434.                               Oldchoice := Choice;
  435.                               Case Upcase(Chpk) of
  436.                               #187 : If TotalPicks >= 1  then choice := 1 else choice := 0;
  437.                               #188 : If TotalPicks >= 2  then choice := 2 else choice := 0;
  438.                               #189 : If TotalPicks >= 3  then choice := 3 else choice := 0;
  439.                               #190 : If TotalPicks >= 4  then choice := 4 else choice := 0;
  440.                               #191 : If TotalPicks >= 5  then choice := 5 else choice := 0;
  441.                               #192 : If TotalPicks >= 6  then choice := 6 else choice := 0;
  442.                               #193 : If TotalPicks >= 7  then choice := 7 else choice := 0;
  443.                               #194 : If TotalPicks >= 8  then choice := 8 else choice := 0;
  444.                               #195 : If TotalPicks >= 9  then choice := 9 else choice := 0;
  445.                               #196 : If TotalPicks >= 10 then choice := 10 else choice := 0;
  446.                               end;  {case}
  447.                               If Choice = 0 then
  448.                                  Choice := Oldchoice
  449.                               else
  450.                               begin
  451.                                   Write_Text(Oldchoice,false);
  452.                                   Write_Text(Choice,true);
  453.                                   Selected := true;
  454.                                   Errorcode := 0;
  455.                               end;
  456.                           end;
  457.              '1'..'0': If (AddPrefix in [1,3]) then   {Number or Function Prefix}
  458.                        begin
  459.                            If (Str_to_int(CHpk) in [1..TotalPicks]) then
  460.                            begin
  461.                                Write_Text(Choice,false);
  462.                                Choice := Str_to_Int(CHpk);
  463.                                Write_Text(Choice,true);
  464.                                Selected := true;
  465.                                ErrorCode := 0;
  466.                            end;
  467.                        end;
  468.              'A'..'Z': If AddPrefix = 2 then
  469.                           If (pos(upcase(CHpk),Alphabet) in [1..TotalPicks]) then
  470.                           begin
  471.                               Write_Text(Choice,false);
  472.                               Choice := pos(upcase(CHpk),Alphabet);
  473.                               Write_Text(Choice,true);
  474.                               Selected := true;
  475.                               Errorcode := 0;
  476.                           end;
  477.                        end;
  478.        Until Selected;
  479.    end; {do}
  480.   end; {proc Process_keystrokes}
  481.  
  482. begin
  483.    GetDimensions;
  484.    CreateMenu;
  485.    Horiz_Sensitivity := 2;  {two cursors left/right before mouse returns}
  486.    Process_Keystrokes;
  487.    If Window then RmWin;
  488. end;        {Main Procedure DisplayMenu}
  489.  
  490.  
  491. end.